home *** CD-ROM | disk | FTP | other *** search
- ;;; -*- Mode:Lisp; Package:CLIO-OPEN; Base:10; Lowercase:T; Syntax:Common-Lisp -*-
-
-
- ;;;----------------------------------------------------------------------------------+
- ;;; |
- ;;; TEXAS INSTRUMENTS INCORPORATED |
- ;;; P.O. BOX 149149 |
- ;;; AUSTIN, TEXAS 78714 |
- ;;; |
- ;;; Copyright (C) 1989, 1990 Texas Instruments Incorporated. |
- ;;; |
- ;;; Permission is granted to any individual or institution to use, copy, modify, and |
- ;;; distribute this software, provided that this complete copyright and permission |
- ;;; notice is maintained, intact, in all copies and supporting documentation. |
- ;;; |
- ;;; Texas Instruments Incorporated provides this software "as is" without express or |
- ;;; implied warranty. |
- ;;; |
- ;;;----------------------------------------------------------------------------------+
-
-
- (in-package "CLIO-OPEN")
-
- (export '(make-property-sheet
- property-sheet
- property-sheet-area
-
- dialog-accept
- dialog-cancel
- ))
-
-
- ;;;----------------------------------------------------------------------------+
- ;;; |
- ;;; property-sheet |
- ;;; |
- ;;;----------------------------------------------------------------------------+
-
- (defcontact property-sheet (core core-wm-shell transient-shell)
- ((previous-pointer-x
- :type (or null int16)
- :initform nil)
- (previous-pointer-y
- :type (or null int16)
- :initform nil)
- (control-default :type (or null contact)
- :initform nil))
-
- (:resources
- (border-width :initform 1)
- (property-area :type (or function list) :initform nil)
- (default-control :type (member :accept :cancel) :initform :accept)
- )
- (:documentation "A dialog which presents a set of related values for user editing."))
-
-
- ;;;----------------------------------------------------------------------------+
- ;;; |
- ;;; Accessors |
- ;;; |
- ;;;----------------------------------------------------------------------------+
-
- (defmethod (setf contact-foreground) :after (new-value (self property-sheet))
- (setf (contact-foreground (car (composite-children self))) new-value))
- (defmethod property-sheet-area ((self property-sheet))
- "Returns the property area of the PROPERTY-SHEET."
- (with-slots (children) (first (slot-value self 'children))
- (find :area children :key #'contact-name)))
-
-
- (defmethod dialog-default-control ((property-sheet property-sheet))
- (with-slots (control-default) property-sheet
- (contact-name control-default)))
-
-
- (defmethod (setf dialog-default-control) (new-value (property-sheet property-sheet))
- (check-type new-value (member :accept :cancel) "one of :ACCEPT or :CANCEL")
- (with-slots (control-default) property-sheet
- (when control-default
- (setf (choice-item-highlight-default-p control-default) nil))
- (setf control-default
- (find new-value (composite-children (first (composite-children property-sheet)))
- :key 'contact-name))
- (setf (choice-item-highlight-default-p control-default) t)
- new-value))
-
- (defmethod dialog-accept ((self property-sheet))
- "Invokes :accept callback function and pops down the dialog"
- (if (callback-p self :accept)
- (apply-callback self :accept)
- (with-slots ((members children)) (property-sheet-area self)
- (dolist (member members)
- (apply-callback member :accept))))
- (with-slots (pinned-p) self
- (unless pinned-p (setf (contact-state self) :withdrawn))))
-
-
- (defmethod dialog-cancel ((self property-sheet))
- "Invokes :cancel callback function and pops down the dialog."
- (with-slots (pinned-p) self
- (unless pinned-p (setf (contact-state self) :withdrawn)))
- (if (callback-p self :cancel)
- (apply-callback self :cancel)
- (with-slots ((members children)) (property-sheet-area self)
- (dolist (member members)
- (apply-callback member :cancel)))))
-
- (defmethod shell-mapped ((self property-sheet))
- "Invokes :initialize callback function."
- (let ((footer (find :footer (composite-children
- (car (composite-children self))) :key 'contact-name)))
- (setf (display-text-source footer) " "))
- (apply-callback self :map)
- (apply-callback-else (self :initialize)
- (with-slots ((members children)) (property-sheet-area self)
- (dolist (member members)
- (apply-callback member :initialize)))))
-
- (defmethod (setf contact-state) :after ((new-state (eql :mapped)) (self property-sheet))
- ;; Pointer warping must occur after :map-notify received, in case root-relative
- ;; positions have been changed by window manager redirection.
- (with-slots (previous-pointer-x previous-pointer-y control-default display) self
- (cond ((realized-p self)
- ;; Store position for pointer unwarping later....
- (multiple-value-setq
- (previous-pointer-x previous-pointer-y) (pointer-position self))
- (warp-pointer
- control-default
- (pixel-round (contact-width control-default) 2)
- (- (contact-height control-default) 2)))
- (t ;; Ensure realized.
- (update-state display))
- )))
-
-
- (defmethod shell-unmapped :before ((self property-sheet))
- (with-slots (previous-pointer-x previous-pointer-y) self
- ;; Unwarp pointer to original position, if necessary.
- (when previous-pointer-x
- (warp-pointer self previous-pointer-x previous-pointer-y))))
-
- (defmethod dialog-warn ((self property-sheet) message field)
- "Display a warning for verification error."
- (assert (or (null field) (typep field 'contact)) nil "~s is not a contact." field)
- (let* ((footer (find :footer (composite-children
- (car (composite-children self))) :key #'contact-name))
- (actual-message (or message "These values cannot be accepted."))
- (tw (text-width (display-text-font footer) actual-message)))
- (if (>= tw (contact-width footer))
- (confirm-p
- :message actual-message
- :near (or field (slot-value self 'control-default))
- :parent self
- :accept-only :on
- )
- (setf (display-text-source footer) actual-message))))
-
-
-
- ;;;----------------------------------------------------------------------------+
- ;;; |
- ;;; Initialization |
- ;;; |
- ;;;----------------------------------------------------------------------------+
-
- (defun make-property-sheet (&rest initargs &key default-control &allow-other-keys)
- "Creates and returns a property-sheet instance."
- (declare (values property-sheet))
- (when default-control
- (assert (symbolp default-control) nil "~s is not a symbol name."))
- (apply #'make-contact 'property-sheet initargs))
-
-
- (defmethod initialize-instance :after ((self property-sheet)
- &key property-area (default-control :accept) &allow-other-keys)
- (multiple-value-bind (area-constructor area-initargs)
- (etypecase property-area
- (null
- (let ((space (ab-height (getf *button-dimensions-by-scale* (contact-scale self)))))
- (values 'make-table
- `(
- :columns 2
- :column-alignment :right
- :same-width-in-column :on
- :same-height-in-row :on
- :horizontal-space ,space
- :vertical-space ,space))))
-
- (function property-area)
-
- (list (values (first property-area) (rest property-area))))
-
- (with-slots (width height) self
-
- ;; Create the manager
- (let ((manager (make-contact 'property-sheet-manager
- :name :manager
- :parent self
- :x 0 :y 0
- :width width :height height
- :border-width 0)))
-
- ;; Create the property area
- (assert (typep (apply area-constructor
- :name :area
- :parent manager
- :x 0 :y 0
- :width width :height height
- :border-width 0
- area-initargs)
- 'composite) nil
- "Property area is not a composite." )
-
- (labels
- ((verify (property-sheet)
- (multiple-value-bind (verified-p message field)
- (or (not (callback-p property-sheet :verify))
- (apply-callback property-sheet :verify))
- (if verified-p
- (dialog-accept property-sheet)
- (dialog-warn property-sheet message field))))
- (menu-accept (property-sheet)
- (verify property-sheet)
- (throw :menu nil))
- (menu-cancel (property-sheet)
- (dialog-cancel property-sheet)
- (throw :menu nil)))
-
- ;; Create buttons for command area
- (add-callback (make-action-button :parent manager :name :accept :label "Apply")
- :release #'verify self)
- (add-callback (make-action-button :parent manager :name :cancel :label "Reset")
- :release #'dialog-cancel self)
-
-
- ;; Create footer area - display-text-field
- (make-display-text-field :parent manager :name :footer :alignment :left
- :display-gravity :west)
-
- ;; Create settings menu
- (let ((choice (menu-choice (make-menu :parent self :title "Settings"))))
- (add-callback (make-action-item :parent choice :name :accept :label "Apply")
- :release #'menu-accept self)
- (add-callback (make-action-item :parent choice :name :cancel :label "Reset")
- :release #'menu-cancel self))
-
- ;; Set default control
- (setf (dialog-default-control self) default-control))))))
-
-
-
-
-
- ;;;----------------------------------------------------------------------------+
- ;;; |
- ;;; property-sheet-manager |
- ;;; |
- ;;;----------------------------------------------------------------------------+
-
-
- (defcontact property-sheet-manager (core composite)
- ((compress-exposures :initform :on))
- (:resources
- (event-mask :initform #.(make-event-mask :exposure)))
- (:documentation "The geometry manager for property sheet component areas."))
-
-
-
- (defmethod change-layout ((self property-sheet-manager) &optional newly-managed)
- (declare (ignore newly-managed))
- (with-slots (width height parent) self
-
- ;; Ensure big enough for property area if possible.
- (multiple-value-bind (pw ph) (preferred-size self)
-
- ;; Let window mgr know new preferred minimum height.
- (with-wm-properties (parent)
- (setf (wm-min-width parent) pw
- (wm-min-height parent) ph))
-
- (let ((rw (when (< width pw) pw))
- (rh (when (< height ph) ph)))
-
- (when
- (or
- ;; Don't need to request larger size?
- (not (or rw rh))
-
- ;; Request for larger size rejected?
- (multiple-value-bind (approved-p nx ny nw nh)
- (change-geometry self :width rw :height rh :accept-p t)
- (declare (ignore nx ny))
- (and (not approved-p) (eql nw width) (eql nh height))))
-
- ;; Yes, adjust child layout for current size.
- (adjust-layout self))))))
-
-
- (defmethod adjust-layout ((psm property-sheet-manager))
- (with-slots (width height children) psm
- (let*
- ((space (point-pixels
- (contact-screen psm)
- (getf *dialog-point-spacing*
- (contact-scale (contact-parent psm)))))
-
- (accept-button (find :accept children :key #'contact-name))
- (abw (contact-border-width accept-button))
- (awidth (+ abw abw (contact-width accept-button)))
- (aheight (+ abw abw (contact-height accept-button)))
-
- (cancel-button (find :cancel children :key #'contact-name))
- (cbw (contact-border-width cancel-button))
- (cwidth (+ cbw cbw (contact-width cancel-button)))
- (cheight (+ cbw cbw (contact-height cancel-button)))
-
- (property-area (find :area children :key #'contact-name))
-
- (footer (find :footer children :key #'contact-name))
- (footer-height (contact-height footer))
- (button-y (- height (+ (max aheight cheight) space footer-height 1)))
- (button-x (pixel-round (- width (+ awidth cwidth space 1)) 2)))
-
- ;; Adjust footer geometry.
- (resize footer width footer-height (contact-border-width footer))
- (move footer 0 (- height footer-height))
-
- ;; Adjust button geometry. Make their top edges align.
- (move accept-button button-x button-y)
- (move cancel-button (+ button-x (+ awidth space)) button-y)
-
- ;; Adjust property-area geometry: preferred size if possible, but
- ;; no more than available space.
- (multiple-value-bind (pw ph) (preferred-size property-area :width 0 :height 0)
- (let ((paw (min (max 1 (- width space space)) pw))
- (pah (min (max 1 (- height space space)) ph)))
- (resize property-area paw pah 0)
-
- ;;Center property-area within available space.
- (move property-area
- (max space (pixel-round (- width paw) 2))
- (max space (pixel-round (- button-y pah) 2))))))))
-
-
-
- (defmethod display ((manager property-sheet-manager) &optional x y width height &key)
- (declare (ignore x y height width))
- (with-slots (width height children foreground) manager
- (let ((footer (find :footer children :key 'contact-name)))
- (using-gcontext (gcontext :drawable manager :background (contact-current-background-pixel manager)
- :foreground foreground :subwindow-mode :include-inferiors)
- (draw-rectangle manager gcontext 0 0
- (max 1 (- width 1))
- (max 1 (- height (contact-height footer) 1))
- )
- ))))
-
-
- (defmethod rescale :after ((contact property-sheet))
- (when (realized-p contact)
- (refresh contact)))
-
- ;;;
- ;;; When the Property Area or one of the Buttons wants to change its geometry we must let it.
- ;;; A change in scale will change the sizes of our children.
- ;;;
-
- (defmethod manage-geometry ((self property-sheet-manager) (child contact)
- x y width height border-width &key)
- (let (success-p)
- (if (or
-
- (and width (> width (contact-width child)))
- (and height (> height (contact-height child)))
- )
- (setf success-p #'(lambda (self)
- (multiple-value-bind (p-w p-h p-b-w)
- (preferred-size self)
- (cond ((and width (< (contact-width self) p-w))
- (change-geometry self
- :width p-w
- :border-width p-b-w
- :accept-p t))
- ((and height (< (contact-height self) p-h))
- (change-geometry self
- :height p-h
- :border-width p-b-w
- :accept-p t))
- (t (change-layout self))))))
- ;; else...
- (setf success-p t))
-
- (values success-p
- (or x (contact-x child))
- (or y (contact-y child))
- (or width (contact-width child))
- (or height (contact-height child))
- (or border-width (contact-border-width child)))))
-
- (defmethod preferred-size ((self property-sheet-manager) &key width height border-width)
- (declare (ignore width height border-width))
- (with-slots (children) self
- (let* ((accumulated-width 0)
- (highest 0)
- (area (find :area children :key #'contact-name))
- (FOOTER (FIND :FOOTER CHILDREN :KEY #'CONTACT-NAME))
- (buttons (REMOVE FOOTER (remove area children)))
- (screen (contact-screen self))
- (scale (contact-scale (contact-parent self)))
- (pixel (getf *dialog-point-spacing* scale))
- (hspace (point-pixels screen pixel :horizontal))
- (vspace (point-pixels screen pixel :vertical)))
-
- ;;Find out how much space the buttons will need.
- ;;Remember: buttons are in a row, so we're interested in combined width
- ;; and the maximum height
- (multiple-value-bind (pwidth1 pheight1 pbw1)
- (preferred-size (first buttons))
- (multiple-value-bind (pwidth2 pheight2 pbw2)
- (preferred-size (second buttons))
- (setf accumulated-width (+ pwidth1 pbw1 pbw1 hspace pwidth2 pbw2 pbw2)
- highest (max (+ pheight1 pbw1 pbw1) (+ pheight2 pbw2 pbw2)))))
-
- ;;We can ignore the preferred border-width because property-sheet-manager
- ;;geometry management forces a zero-width border.
- (multiple-value-bind (pwidth pheight)
- (preferred-size area :width 0 :height 0)
- (MULTIPLE-VALUE-BIND (f-pwidth F-PHEIGHT)
- (PREFERRED-SIZE FOOTER)
- (declare (ignore f-pwidth))
- (values (+ (max pwidth accumulated-width) hspace hspace 2)
- (+ pheight highest F-PHEIGHT vspace vspace vspace 2) ;; add two for rectangle
- 0)))))) ;; drawn around property-area
-
-
- (defmethod resize :after ((self property-sheet-manager) width height border-width)
- (declare (ignore width height border-width))
- (adjust-layout self))
-
-
-
-
-
- ;;;----------------------------------------------------------------------------+
- ;;; |
- ;;; Actions |
- ;;; |
- ;;;----------------------------------------------------------------------------+
-
- (defevent property-sheet-manager :enter-notify property-sheet-forget-warp)
-
- (defevent property-sheet (:button-press :button-3) property-sheet-display-menu)
-
- (defun property-sheet-forget-warp (property-sheet-manager)
- (with-slots (parent) (the property-sheet-manager property-sheet-manager)
- (with-slots (previous-pointer-x) (the property-sheet parent)
- (with-event (kind)
- ;; Entering from a child? The first time this happens the child must be
- ;; the default control. Open Look GUI thus dictates that pointer will not
- ;; warp to original position after exiting the property-sheet
- (when (eq kind :inferior)
- (setf previous-pointer-x nil))))))
-
- (defun property-sheet-display-menu (property-sheet)
- (let ((menu (first (composite-shells property-sheet)))
- (display (contact-display property-sheet)))
-
- ;; Pop up settings menu
- (present-dialog menu :button :button-3 :state (with-event (state) state))
-
- (catch :menu
- (loop (process-next-event display)))
-
- ;; Pop down settings menu
- (setf (contact-state menu) :withdrawn)))
-
-
-
-
-